CD Actual 9/CDACTUAL9.iso/share/Dos/VARIOS/pascal/SWAG9605.DDD/0080_Marquee Panel For Delphi.pas

Pascal/Delphi Source File | 1996-05-31 | 14.3 KB | 513 lines

{
  This component uses the VGA standard 8x16 font. No resources are used.

  properties description:

    property BackGround:     Background color of panel. Not visible if size is 1,
                             because pixeldensity is too high.

    property BevelOuter:     as usual.
    property BevelInner:     as usual.
    property BevelWidth:     as usual.
    property Characters:     How many Character are displayed in panel.
                             Increasing this slows down the outputspeed.
    property OffColor:       Color of Pixels not set in character.
    property OnColor:        Color of Pixels set in character.
    property OnComplete:     Fired if output of RunText completed.
    property Running:        Flag if horizontal scrolling is active.
    property RunText:        Outputstring.
    property ScrollBy:       Number of pixels per horizontal scroll.
    property ScrollInterval: Cycletime of horizontal scrolling.
    property Size:           Size of output. If set to 1 character size is 8x16
                             pixels. Increasing size decreases display contrast.

  Contact: Udo Juerss, 57078 Siegen, Germany, CompuServe [101364,526]

  Previously published by me: Luffing switch      (March  8. 1996)
                              Scaleable LED light (March 10. 1996)

  If someone makes useful enhances or corrections to these components,
  please send me an update!

  March 11. 1996
}

unit
  Marquee;
{------------------------------------------------------------------------------}

interface

uses
  WinTypes, WinProcs, Messages, Classes, Graphics, Controls, ExtCtrls;
{------------------------------------------------------------------------------}

const
  Dual: array[0..7] of Byte = (1,2,4,8,16,32,64,128);
{------------------------------------------------------------------------------}

type
  TMarquee = class(TGraphicControl)
  private
    Timer: TTimer;

    FBackGround: TColor;
    FBevelOuter: TPanelBevel;
    FBevelInner: TPanelBevel;
    FBevelWidth: Byte;
    FBkGnd: TColor;
    FCharacters: Byte;
    FScrollInterval: Word;
    FOffColor: TColor;
    FOnColor: TColor;
    FOnComplete: TNotifyEvent;
    FRunning: Boolean;
    FRunText: string;
    FSize: Byte;
    FScrollBy: Byte;

    Border:Byte;
    Index: Byte;
    WorkString: string;
    PixelPos: Byte;
    CharOfs: Word;
    TextLen: Byte;
    XPos: Integer;
    YPos: Integer;
    procedure Draw;
    procedure DrawText(Shift:Boolean);
    procedure GetCharData(Character: Char);
    procedure PutVerticalPixels(Horizontal: Byte);
    procedure Setup;
    procedure ShiftString;
    procedure TimerShift(Sender: TObject);
  protected
    procedure DrawBevel(Rect: TRect);
    procedure SetBackGround(Value: TColor);
    procedure SetBevelOuter(Value: TPanelBevel);
    procedure SetBevelInner(Value: TPanelBevel);
    procedure SetBevelWidth(Value: Byte);
    procedure SetCharacters(Value: Byte);
    procedure SetScrollInterval(Value: Word);
    procedure SetOffColor(Value: TColor);
    procedure SetOnColor(Value: TColor);
    procedure SetRunning(Value: Boolean);
    procedure SetRunText(Value: string);
    procedure SetSize(Value: Byte);
    procedure SetScrollBy(Value: Byte);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear;
    procedure Paint; override;
  published
    property BackGround: TColor read FBackGround write SetBackGround default clBlack;
    property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvRaised;
    property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvLowered;
    property BevelWidth: Byte read FBevelWidth write SetBevelWidth default 2;
    property Characters: Byte read FCharacters write SetCharacters default 7;
    property ScrollInterval: Word read FScrollInterval write SetScrollInterval default 50;
    property OffColor: TColor read FOffColor write SetOffColor default clGray;
    property OnColor: TColor read FOnColor write SetOnColor default clLime;
    property OnComplete: TNotifyEvent read FOnComplete write FOnComplete;
    property Running: Boolean read FRunning write SetRunning default False;
    property RunText: string read FRunText write SetRunText;
    property ScrollBy: Byte read FScrollBy write SetScrollBy default 1;
    property Size: Byte read FSize write SetSize default 2;
  end;
{------------------------------------------------------------------------------}

procedure GetFontOfs(CharSet: Byte; var FntOfs: Word);
function SegC000: Word;
procedure Register;

implementation
{------------------------------------------------------------------------------}

var
  CharArray: array[0..15] of Byte;
  FontPtr: Pointer;
  FontOfs: Word;
{------------------------------------------------------------------------------}

procedure GetFontOfs(CharSet: Byte; var FntOfs: Word); assembler;
asm
           push  bp
           mov   ax,1130h
           mov   bh,CharSet
           int   10h
           mov   ax,bp
           pop   bp
           les   di,FntOfs
           stosw
end;
{------------------------------------------------------------------------------}

function SegC000: Word; external 'KERNEL' Index 195;
{------------------------------------------------------------------------------}

constructor TMarquee.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parent:=AOwner as TWinControl;
  Canvas.Brush.Style:=bsSolid;
  Timer:=nil;
  FBackGround:=clBlack;
  FBevelOuter:=bvRaised;
  FBevelInner:=bvLowered;
  FBevelWidth:=2;
  FCharacters:=7;
  FScrollInterval:=50;
  FOffColor:=clGray;
  FOnColor:=clLime;
  FOnComplete:=nil;
  FRunning:=False;
  FRunText:='RunText ';
  FSize:=2;
  FScrollBy:=1;

  Border:=2;
  GetFontOfs(6,FontOfs);
  FontPtr:=Ptr(Ofs(SegC000),FontOfs);

  PixelPos:=0;
  TextLen:=Length(FRunText);
  Index:=0;
  WorkString:=FRunText;
  Setup;
  Draw;
end;
{------------------------------------------------------------------------------}

destructor TMarquee.Destroy;
begin
  if FRunning then SetRunning(False);
  inherited Destroy;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.Paint;
begin
  Draw;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.Clear;
var
  Temp: Byte;
begin
  Temp:=FOnColor;
  FOnColor:=FOffColor;
  DrawText(False);
  FOnColor:=Temp;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.Draw;
var
  R: TRect;
begin
  R:=GetClientRect;
  DrawBevel(R);
  Canvas.Pen.Color:=FBackGround;
  Canvas.Brush.Color:=FBackGround;
  InflateRect(R,-Border,-Border);
  Canvas.FillRect(R);
  DrawText(False);
end;
{------------------------------------------------------------------------------}

procedure TMarquee.DrawBevel(Rect: TRect);
var
  TopColor: TColor;
  BottomColor: TColor;

  procedure SetColors(Bevel: TPanelBevel);
  begin
    TopColor:=clBtnHighlight;
    if Bevel = bvLowered then TopColor:=clBtnShadow;
    BottomColor:=clBtnShadow;
    if Bevel = bvLowered then BottomColor:=clBtnHighlight;
  end;

begin
  if FBevelOuter <> bvNone then
  begin
    SetColors(BevelOuter);
    Frame3D(Canvas,Rect,TopColor,BottomColor,BevelWidth);
  end;

  if FBevelInner <> bvNone then
  begin
    SetColors(FBevelInner);
    Frame3D(Canvas,Rect,TopColor,BottomColor,FBevelWidth);
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.DrawText(Shift: Boolean);
var
  Pos: Byte;
  I: Byte;
  R: TRect;
begin
  R:=GetClientRect;
  XPos:=R.Left + Border;
  YPos:=R.Top + Border;
  GetCharData(WorkString[1]);
  for I:=PixelPos to 7 do PutVerticalPixels(I);

  for Pos:=2 to FCharacters do
  begin
    GetCharData(WorkString[Pos]);
    for I:=0 to 7 do PutVerticalPixels(I);
  end;

  GetCharData(WorkString[Succ(FCharacters)]);
  for I:=0 to PixelPos do PutVerticalPixels(I);

  if Shift then Inc(PixelPos,FScrollBy);
  if PixelPos > 7 then
  begin
    PixelPos:=0;
    ShiftString;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.GetCharData(Character: Char); assembler;
asm
           push  ds
           push  ds
           pop   es
           mov   di,offset CharArray
           xor   bh,bh
           mov   bl,Character
           shl   bx,4
           lds   si,FontPtr
           add   si,bx
           mov   cx,16

@MovsLoop: push  cx
           lodsb
           mov   ah,0
           mov   cx,8

@RolLoop:  rol   al,1
           adc   ah,0
           ror   ah,1
           loop  @RolLoop

           mov   al,ah
           stosb
           pop   cx
           loop  @MovsLoop

           pop   ds
end;
{------------------------------------------------------------------------------}

procedure TMarquee.PutVerticalPixels(Horizontal: Byte);
var
  Vertical: Byte;
begin
  for Vertical:=0 to 15 do
  begin
    if CharArray[Vertical] and Dual[Horizontal] > 0 then
      Canvas.Pixels[XPos,YPos + Vertical * FSize]:=FOnColor
      else Canvas.Pixels[XPos,YPos + Vertical * FSize]:=FOffColor;
  end;
  Inc(XPos,FSize);
end;
{------------------------------------------------------------------------------}

procedure TMarquee.TimerShift(Sender: TObject);
begin
  DrawText(True);
end;
{------------------------------------------------------------------------------}

procedure TMarquee.ShiftString;
begin
  Inc(Index);
  if FCharacters >= TextLen - Index then
  begin
    WorkString:=Copy(FRunText,Succ(Index),TextLen - Index);
    WorkString:=WorkString + Copy(RunText,1,Succ(FCharacters) - (TextLen - Index));
  end
  else WorkString:=Copy(FRunText,Succ(Index),Succ(FCharacters));
  if Index >= TextLen then
  begin
    Index:=0;
    if Assigned(FOnComplete) then FOnComplete(Self);
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.Setup;
begin
  Width:=FSize * 8 * FCharacters + 2 * Border + 1;
  Height:=FSize * 16 + 2 * Border;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetBackGround(Value: TColor);
begin
  if FBackGround <> Value then
  begin
    FBackGround:=Value;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetBevelOuter(Value: TPanelBevel);
begin
  if FBevelOuter <> Value then
  begin
    FBevelOuter:=Value;
    if FBevelOuter <> bvNone then Border:=FBevelWidth else Border:=0;
    if FBevelInner <> bvNone then Inc(Border,FBevelWidth);
    Setup;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetBevelInner(Value: TPanelBevel);
begin
  if FBevelInner <> Value then
  begin
    FBevelInner:=Value;
    if FBevelOuter <> bvNone then Border:=FBevelWidth else Border:=0;
    if FBevelInner <> bvNone then Inc(Border,FBevelWidth);
    Setup;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetBevelWidth(Value: Byte);
begin
  if FBevelWidth <> Value then
  begin
    FBevelWidth:=Value;
    if FBevelOuter <> bvNone then Border:=FBevelWidth else Border:=0;
    if FBevelInner <> bvNone then Inc(Border,FBevelWidth);
    Setup;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetCharacters(Value: Byte);
var
  I: Byte;
begin
  if Value < 1 then Value:=1 else if Value > 80 then Value:=80;
  if FCharacters <> Value then
  begin
    FCharacters:=Value;
    if TextLen < FCharacters then
    begin
      for I:=TextLen to FCharacters do FRunText:=FRunText + ' ';
      TextLen:=Byte(FRunText[0]);
    end;
    SetUp;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetScrollInterval(Value: Word);
begin
  if FScrollInterval <> Value then
  begin
    FScrollInterval:=Value;
    if FRunning and Assigned(Timer) then Timer.Interval:=FScrollInterval;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetSize(Value: Byte);
begin
  if Value < 1 then Value:=1 else if Value > 8 then Value:=8;
  if FSize <> Value then
  begin
    FSize:=Value;
    SetUp;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetScrollBy(Value: Byte);
begin
  if Value < 1 then Value:=1 else if Value > 8 then Value:=8;
  if FScrollBy <> Value then FScrollBy:=Value;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetOffColor(Value: TColor);
begin
  if FOffColor <> Value then
  begin
    FOffColor:=Value;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetOnColor(Value: TColor);
begin
  if FOnColor <> Value then
  begin
    FOnColor:=Value;
    Draw;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetRunning(Value: Boolean);
begin
  if FRunning <> Value then
  begin
    FRunning:=Value;
    if FRunning then
    begin
      Timer:=TTimer.Create(Self);
      Timer.Interval:=FScrollInterval;
      Timer.OnTimer:=TimerShift;
      Timer.Enabled:=True;
    end
    else if Assigned(Timer) then
    begin
      Timer.Free;
      Timer:=nil;
    end;
  end;
end;
{------------------------------------------------------------------------------}

procedure TMarquee.SetRunText(Value: string);
var
  I: Byte;
begin
  Index:=0;
  FRunText:=Value;
  TextLen:=Byte(FRunText[0]);
  if TextLen < FCharacters then for I:=TextLen to FCharacters do FRunText:=FRunText + ' ';
  TextLen:=Byte(FRunText[0]);
end;
{------------------------------------------------------------------------------}

procedure Register;
begin
  RegisterComponents('Udo|s',[TMarquee]);
end;
{------------------------------------------------------------------------------}

initialization
end.